BBS in a Box 15/BBS in a box XV-1.iso/Files/Game/B/BoloRandomMap 1.10.sit/Bolo RandomMap 1.1.0/Bolo RandomMap.p

Text File | 1993-07-01 | 18.4 KB | 879 lines | [TEXT/PJMM]

program BoloRandomMap;

{ Bolo RandomMap © Peter N Lewis, 1993 }
{ This source code is free and may be used for any purpose }

    uses
        MyUtils, MyDialogs, FixMath, MyUtilities, MyStandardFile;

{$D-}
    const
        max_rows = 255;
        max_cols = 255;
        max_height = 255;
        max_pillboxes = 16;
        max_bases = 16;
        max_starts = 16;
        max_que = 256;

    type
        lands = (L_Building, L_River, L_Swamp, L_Crater, L_Road, L_Forest, L_Rubble, L_Grass,{}
            L_ShotBuilding, L_Boat, L_MSwamp, L_MCrater, L_MRoad, L_MForest, L_MRubble, L_MGrass,{}
            L_DeepSea);
        landSet = set of lands;

    const
        L_First = L_Building;
        L_Last = L_DeepSea;
        All_Locations = [L_First..L_Last];
        flat_set = [L_Swamp, L_Crater, L_Road, L_Forest, L_Rubble, L_Grass];

    type
        mapArray = packed array[1..max_rows, 1..max_cols] of byte;
        mapPtr = ^mapArray;
        landArray = packed array[1..max_rows, 1..max_cols] of lands;
        landPtr = ^landArray;
        location = record
                r, c: integer;
            end;

    const
        version = 1;
        land_strs = '# %C*^RX=BABCDEF~';

    var
        rows, cols, land, forest: integer;
        mp, mp2: mapPtr;
        lp, lp2: landPtr;
        pillboxes, bases: integer;
        base_armour, base_shells, base_mines: integer;
        pillbox_locations: array[1..max_pillboxes] of location;
        base_locations: array[1..max_bases] of location;
        que: array[0..max_que] of location;
        q_head, q_tail, q_size: integer;
        display: dialogPtr;
        prog_parts, prog_parts_done, prog_base, prog_base_done: integer;
        random_location_failed: boolean;

    procedure DrawProgress (dlg: dialogPtr; item: integer);
        const
            HiliteRGBP = $DA0;
        type
            RGBColorPtr = ^RGBColor;
        var
            box: rect;
            w, uw: integer;
            oldfore: RGBColor;
    begin
        Setport(dlg);
        GetDItemRect(dlg, item, box);
        FrameRect(box);
        InsetRect(box, 1, 1);
        with box do begin
            w := right - left;
            uw := FracMul(w, FracDiv(prog_base * prog_parts_done + prog_base_done, prog_parts * prog_base));
            right := left + uw;
            if has_colorQD and false then begin
                GetForeColor(oldfore);
                RGBForeColor(RGBColorPtr(HiliteRGBP)^);
                PaintRect(box);
                RGBForeColor(oldfore);
            end
            else
                FillRect(box, gray);
            left := right;
            right := right + w - uw;
            EraseRect(box);
        end;
    end;

    procedure WNE;
        var
            dummy: boolean;
            er: eventRecord;
            dlg: dialogPtr;
            item: integer;
    begin
        DrawProgress(display, 1);
        dummy := WaitNextEvent(everyEvent, er, 1, nil);
        if IsDialogEvent(er) then
            dummy := DialogSelect(er, dlg, item);
    end;

    procedure StartPart (base: longInt);
        var
            s: str255;
    begin
        prog_parts_done := prog_parts_done + 1;
        GetIndString(s, 201, prog_parts_done + 1);
        SetItemText(display, 11, s);
        prog_base_done := 0;
        prog_base := base;
    end;

    procedure ProgRow (r: integer);
    begin
        if r > prog_base then
            r := prog_base;
        prog_base_done := r;
        WNE;
    end;

    procedure InitQue;
    begin
        q_head := 0;
        q_tail := 0;
        q_size := 0;
    end;

    procedure AddQue (var l: location);
    begin
        if q_size < max_que then begin
            que[q_head] := l;
            q_head := (q_head + 1) mod max_que;
            q_size := q_size + 1;
        end;
    end;

    procedure GetQue (var l: location);
    begin
        if q_size > 0 then begin
            l := que[q_tail];
            q_tail := (q_tail + 1) mod max_que;
            q_size := q_size - 1;
        end;
    end;

    function EmptyQue: boolean;
    begin
        EmptyQue := q_size = 0;
    end;

    function Rand (n: longInt): longInt;
    begin
        Rand := BAND(BOR(BSL(longInt(Random), 16), BAND(Random, $7FFF)), $7FFFFFFF) mod n;
    end;

    function RandBetween (a, b: longInt): longInt;
    begin
        if b = a then begin
            RandBetween := a;
        end
        else begin
            RandBetween := a + Rand(b - a + 1);
        end;
    end;

    procedure DrawMap;
        var
            r, c: integer;
            s: str255;
    begin
        for r := 1 to rows do begin
 {$PUSH}
{$R-}
            s[0] := chr(cols * 2);
{$POP}
            for c := 1 to cols do begin
                s[c * 2 - 1] := land_strs[mp^[r, c] + 1];
                s[c * 2] := land_strs[mp^[r, c] + 1];
            end;
            writeln(s);
        end;
    end;

    function CalcPercentage (h: integer): integer;
        var
            r, c: integer;
            count: longInt;
    begin
        count := 0;
        for r := 1 to rows do begin
            for c := 1 to cols do begin
                if mp^[r, c] >= h then
                    count := count + 1;
            end;
        end;
        CalcPercentage := count * 100 div (longInt(rows - 2) * (cols - 2)); { allow for edge sea squares }
    end;

    function FindHeight (p: integer): integer;
        var
            h: integer;
            min, max, pp: integer;
    begin
        min := 0;
        max := max_height;
        while (min < max) do begin
            h := (min + max) div 2;
            pp := CalcPercentage(h);
            if p = pp then begin
                leave;
            end
            else if pp < p then begin
                max := h - 1;
            end
            else begin
                min := h + 1;
            end;
        end;
        FindHeight := min;
    end;

    procedure Threshold (h: integer);
        var
            r, c: integer;
    begin
        StartPart(rows);
        for r := 1 to rows do begin
            ProgRow(r);
            for c := 1 to cols do begin
                mp^[r, c] := ord(mp^[r, c] >= h);
            end;
        end;
    end;

    procedure RandomHeights;
        function GetFactor (i, max: integer): integer;
            var
                f: integer;
        begin
            f := max - i + 1;
            if f > i then
                f := i;{ f=distance from edge, starting at 1 }
            if f > 4 then
                f := 4;
            f := 5 - f;
            GetFactor := f;
        end;

        var
            r, c: integer;
            dr, dc: integer;
    begin
        StartPart(rows);
        for r := 1 to rows do begin
            ProgRow(r);
            dr := GetFactor(r, rows);
            for c := 1 to cols do begin
                dc := GetFactor(c, cols);
                mp^[r, c] := Rand(max_height div dr div dc);
            end;
        end;
    end;

    procedure Smooth;
        var
            r, c, dr, dc, rr, cc, v, count: integer;
    begin
        StartPart(rows);
        mp2^ := mp^;
        for r := 1 to rows do begin
            ProgRow(r);
            for c := 1 to cols do begin
                v := 0;
                for dr := -2 to 2 do begin
                    for dc := -2 to 2 do begin
                        rr := r + dr;
                        cc := c + dc;
                        if (1 <= rr) & (rr <= rows) & (1 <= cc) & (cc <= cols) then begin
                            v := v + mp2^[rr, cc];
                        end;
                    end;
                end;
                mp^[r, c] := v div 25;
            end;
        end;
    end;

    procedure LoseIslands;
        var
            r, c, dr, dc, rr, cc, count: integer;
    begin
        StartPart(rows);
        mp2^ := mp^;
        for r := 1 to rows do begin
            ProgRow(r);
            for c := 1 to cols do begin
                count := 0;
                for dr := -1 to 1 do begin
                    for dc := -1 to 1 do begin
                        if (dr <> 0) | (dc <> 0) then begin
                            rr := r + dr;
                            cc := c + dc;
                            if (1 <= rr) & (rr <= rows) & (1 <= cc) & (cc <= cols) then begin
                                count := count + mp2^[rr, cc];
                            end;
                        end;
                    end;
                end;
                if count = 0 then
                    mp^[r, c] := 0
                else if count = 8 then
                    mp^[r, c] := 1;
            end;
        end;
    end;

    procedure TrimEdges;
        var
            r, c: integer;
    begin
        for r := 1 to rows do begin
            mp^[r, 1] := 0;
            mp^[r, cols] := 0;
        end;
        for c := 1 to cols do begin
            mp^[1, c] := 0;
            mp^[rows, c] := 0;
        end;
    end;

    procedure ConvertToLand;
        var
            r, c, dr, dc, rr, cc, count: integer;
    begin
        StartPart(rows);
        for r := 1 to rows do begin
            ProgRow(r);
            for c := 1 to cols do begin
                if mp^[r, c] = 0 then begin
                    lp^[r, c] := L_River;
                end
                else begin
                    lp^[r, c] := L_Grass;
                end;
            end;
        end;
    end;

    procedure InitLocations;
        var
            i: integer;
    begin
        random_location_failed := false;
        for i := 1 to max_pillboxes do begin
            pillbox_locations[i].r := -1;
            pillbox_locations[i].c := -1;
        end;
        for i := 1 to max_bases do begin
            base_locations[i].r := -1;
            base_locations[i].c := -1;
        end;
    end;

    procedure GetRandomLandLocation (var l: location; ls: landSet);
        var
            good: boolean;
            i: integer;
            loopcheck: integer;
    begin
        loopcheck := 200;
        repeat
            l.r := RandBetween(1, rows);
            l.c := RandBetween(1, cols);
            good := lp^[l.r, l.c] in ls;
            if good then begin
                for i := 1 to max_pillboxes do begin
                    if (pillbox_locations[i].r = l.r) and (pillbox_locations[i].c = l.c) then
                        good := false;
                end;
                for i := 1 to max_bases do begin
                    if (base_locations[i].r = l.r) and (base_locations[i].c = l.c) then
                        good := false;
                end;
            end;
            loopcheck := loopcheck - 1;
        until good or (loopcheck = 0);
        if not good then begin
            random_location_failed := true;
        end;
    end;

    procedure GetRandomLocation (var l: location);
    begin
        GetRandomLandLocation(l, All_Locations);
    end;

    function CalcPercentageOfLand (l: lands): integer;
        var
            r, c: integer;
            solid, land: longInt;
    begin
        solid := 0;
        land := 0;
        for r := 1 to rows do begin
            for c := 1 to cols do begin
                if (lp^[r, c] <> L_River) & (lp^[r, c] <> L_Boat) then begin
                    solid := solid + 1;
                    if lp^[r, c] = l then
                        land := land + 1;
                end;
            end;
        end;
        CalcPercentageOfLand := land * 100 div solid;
    end;

    function CountLand (ls: landSet): longInt;
        var
            r, c: integer;
            count: longInt;
    begin
        count := 0;
        for r := 1 to rows do begin
            for c := 1 to cols do begin
                if lp^[r, c] in ls then begin
                    count := count + 1;
                end;
            end;
        end;
        CountLand := count;
    end;
{$D+}

    procedure AddDeepSea;
        var
            r, c: integer;
            dr, dc: integer;
            rr, cc: integer;
            count: integer;
            allsea: boolean;
    begin
        StartPart(rows);
        for r := 1 to rows do begin
            ProgRow(r);
            for c := 1 to cols do begin
                allsea := true;
                for dr := -2 to 2 do begin
                    for dc := -2 to 2 do begin
                        if abs(dr) + abs(dc) <= 3 then begin
                            rr := r + dr;
                            cc := c + dc;
                            if (1 <= rr) & (rr <= rows) & (1 <= cc) & (cc <= cols) & not (lp^[rr, cc] in [L_River, L_DeepSea]) then begin
                                allsea := false;
                                leave; { should leave both dr and dc loops, oh well }
                            end;
                        end;
                    end; { dc}
                end; { dr }
                if allsea then
                    lp^[r, c] := L_DeepSea;
            end; { c}
        end; { r }
    end;

    procedure AddForrests;
        var
            l, m: location;
            i, p, f: integer;
            dr, dc: integer;
            doit: boolean;
            forest_needed, forest_sofar, divider: longInt;
    begin
        forest_sofar := 0;
        forest_needed := CountLand([L_Grass]) * forest div 100;
        divider := forest_needed div 100 + 1;
        StartPart(forest_needed div divider);
        while forest_sofar < forest_needed do begin
            ProgRow(forest_sofar div divider);
            InitQue;
            GetRandomLandLocation(l, [L_Grass]);
            AddQue(l);
            p := RandBetween(20, 500);
            for i := 1 to p do begin
                if EmptyQue then
                    leave;
                GetQue(l);
                if lp^[l.r, l.c] = L_Grass then begin
                    lp^[l.r, l.c] := L_Forest;
                    forest_sofar := forest_sofar + 1;
                    for dr := -1 to 1 do begin
                        for dc := -1 to 1 do begin
                            m.r := l.r + dr;
                            m.c := l.c + dc;
                            if ((dr <> 0) or (dc <> 0)) & (lp^[m.r, m.c] = L_Grass) & (Rand(10) < 5) then begin
                                AddQue(m);
                            end; { if }
                        end; { for dc }
                    end; { for dr }
                end; { if still grass }
            end; { for i }
        end; { while }
    end; { proc }

    procedure AddRivers;
    begin
    end;

    procedure AddRoads;
    begin
    end;

    procedure FillOutLandscape;
    begin
        ConvertToLand;
        AddDeepSea;
        AddForrests;
        AddRivers;
        AddRoads;
    end;

    procedure PlaceBases;
        var
            i: integer;
            l: location;
    begin
        for i := 1 to bases do begin
            GetRandomLandLocation(l, [L_Swamp, L_Crater, L_Road, L_Forest, L_Rubble, L_Grass, L_Forest]);
            if lp^[l.r, l.c] = L_Forest then
                lp^[l.r, l.c] := L_Grass;
            base_locations[i] := l;
        end;
    end;

    procedure PlacePillboxes;
        var
            i: integer;
            l: location;
    begin
        for i := 1 to pillboxes do begin
            GetRandomLandLocation(l, [L_Swamp, L_Crater, L_Road, L_Forest, L_Rubble, L_Grass, L_Forest]);
            if lp^[l.r, l.c] = L_Forest then
                lp^[l.r, l.c] := L_Grass;
            pillbox_locations[i] := l;
        end;
    end;

    procedure BuildMap;
    begin
        InitLocations;
        RandomHeights;
        Smooth;
        Threshold(FindHeight(land));
        LoseIslands;
        TrimEdges;
        FillOutLandscape;
        PlaceBases;
        PlacePillboxes;
    end;

    procedure WriteMap;
        var
            refnum: integer;
            roff, coff: integer;

        procedure WriteData (p: ptr; count: longInt);
            var
                oe: OSErr;
        begin
            if count > 0 then
                oe := FSWrite(refnum, count, p);
        end;

        procedure WriteString (s: str255);
            var
                count: longInt;
                oe: OSErr;
        begin
            count := length(s);
            if length(s) > 0 then
                oe := FSWrite(refnum, count, @s[1]);
        end;

        procedure WriteByte (b: integer);
        begin
            WriteString(chr(b));
        end;

        procedure WriteLocation (var l: location);
        begin
            WriteByte(l.c + coff);
            WriteByte(l.r + roff);
        end;

        procedure WritePreamble;
        begin
            WriteString('BMAPBOLO');
            WriteByte(version);
            WriteByte(pillboxes);
            WriteByte(bases);
            WriteByte(max_starts);
        end;

        procedure WritePillboxInfo;
            var
                i: integer;
        begin
            for i := 1 to pillboxes do begin
                WriteLocation(pillbox_locations[i]);
                WriteByte($FF); { owner }
                WriteByte(15); { strength - full }
                WriteByte(50); { speed - initially sleepy }
            end;
        end;

        procedure WriteBaseInfo;
            var
                i: integer;
        begin
            for i := 1 to bases do begin
                WriteLocation(base_locations[i]);
                WriteByte($FF); { owner }
                WriteByte(base_armour); { armour (0-90) }
                WriteByte(base_shells); { shells (0-90) }
                WriteByte(base_mines); { mines (0-90) }
            end;
        end;

        procedure WriteStartInfo;
            procedure WriteStart (r, c, d: integer);
                var
                    l: location;
            begin
                l.r := r;
                l.c := c;
                WriteLocation(l);
                WriteByte(d);
            end;
            var
                i: integer;
        begin
            WriteStart(-2, -2, 14);
            WriteStart(rows + 2, -2, 2);
            WriteStart(rows + 2, cols + 2, 6);
            WriteStart(-2, cols + 2, 10);
            for i := 1 to 3 do begin
                WriteStart(-2, cols * i div 4, 12);
                WriteStart(rows + 2, cols * i div 4, 4);
            end;
            for i := 1 to 3 do begin
                WriteStart(rows * i div 4, -2, 0);
                WriteStart(rows * i div 4, cols + 2, 8);
            end;
        end;

        procedure WriteHeader;
        begin
            WritePreamble;
            WritePillboxInfo;
            WriteBaseInfo;
            WriteStartInfo;
        end;

        procedure WriteRows;

            var
                nibble_flag: boolean;
                nibble_data: integer;
                nibbles: packed array[0..512] of byte;

            procedure PutNibble (n: integer);
            begin
                if not nibble_flag then begin
                    nibble_flag := true;
                    nibbles[nibble_data] := BSL(n, 4);
                end
                else begin
                    nibble_flag := false;
                    nibbles[nibble_data] := BOR(nibbles[nibble_data], n);
                    nibble_data := nibble_data + 1;
                end;
            end;

            var
                code, r, c: integer;
                t: lands;
                ds, i: integer;
                startc: integer;
        begin
            StartPart(rows);
            r := 1;
            c := 1;
            while (r <= rows) do begin
                if c > cols then begin
                    c := 1;
                    r := r + 1;
                    ProgRow(r);
                end;
                while (r <= rows) & (lp^[r, c] = L_DeepSea) do begin
                    c := c + 1;
                    if c > cols then begin
                        c := 1;
                        r := r + 1;
                        ProgRow(r);
                    end;
                end;

                if r <= rows then begin
                    startc := c;
                    nibble_flag := false;
                    nibble_data := 0;
                    while (c <= cols) & (lp^[r, c] <> L_DeepSea) do begin
                        t := lp^[r, c];
                        if (c < cols) & (t = lp^[r, c + 1]) then begin
                            code := 8; { 8 means 2 repeated squares }
                            c := c + 2;
                            while (code < 15) & (c <= cols) & (lp^[r, c] = t) do begin
                                code := code + 1;
                                c := c + 1;
                            end;
                            PutNibble(code);
                            PutNibble(ord(t));
                        end
                        else begin
                            code := 0; { 0 means 1 individual square }
                            ds := c;
                            c := c + 1;
                            while (code < 7) & (c <= cols) & (lp^[r, c] <> L_DeepSea) & ((c = cols) | (lp^[r, c] <> lp^[r, c + 1])) do begin
                                code := code + 1;
                                c := c + 1;
                            end;
                            PutNibble(code);
                            for i := ds to c - 1 do
                                PutNibble(ord(lp^[r, i]));
                        end;
                    end;
                    if nibble_flag then
                        PutNibble(0);
                    WriteByte(nibble_data + 4);
                    WriteByte(r + roff);
                    WriteByte(startc + coff);
                    WriteByte(c + coff);
                    WriteData(@nibbles, nibble_data);
                end; { if r<=rows }
            end; { while r<=rows }
            WriteByte(4);
            WriteByte($FF);
            WriteByte($FF);
            WriteByte($FF);
        end; { proc }

        var
            oe: OSErr;
            fs: FSSpec;
            where: point;
            reply: MySFreply;
    begin
        roff := (256 - rows) div 2;
        coff := (256 - cols) div 2;
        SetPt(where, 40, 40);
        PutFile('Save File as:', 'Random Map', reply);
        with reply do begin
            if Rgood then begin
                oe := HCreate(RvRefNum, RdirID, RfName, 'BOLO', 'BMAP');
                if oe = dupFnErr then begin
                    oe := HDelete(RvRefNum, RdirID, RfName);
                    oe := HCreate(RvRefNum, RdirID, RfName, 'BOLO', 'BMAP');
                end;
                oe := HOpen(RvRefNum, RdirID, RfName, fsWrPerm, refnum);
                if oe = noErr then begin
                    WriteHeader;
                    WriteRows;
                    oe := FSClose(refnum);
                end;
            end;
        end;
    end;

    function GetParameters: boolean;
        var
            dlg: dialogPtr;
        procedure GetPair (item, dispitem: integer; var v: integer; min, max, rmin, rmax: integer);
            var
                s1, s2: str255;
        begin
            GetItemText(dlg, item, s1);
            GetItemText(dlg, item + 1, s2);
            if (s1 <> '') | (s2 <> '') then begin
                if s1 = '' then
                    s1 := s2;
                if s2 = '' then
                    s2 := s1;
                rmin := StrToNum(s1);
                rmax := StrToNum(s2);
            end;
            if rmin > rmax then begin
                v := rmin;
                rmin := rmax;
                rmax := v;
            end;
            if rmin < min then
                rmin := min;
            if rmax < min then
                rmax := min;
            if rmin > max then
                rmin := max;
            if rmax > max then
                rmax := max;
            v := RandBetween(rmin, rmax);
            SetItemText(display, dispitem, NumToStr(v));
        end;

        var
            good: boolean;
            item: integer;
    begin
        dlg := GetNewDialog(200, nil, POINTER(-1));
        SetUpDefaultOutline(dlg, 1, 3);
        ShowWindow(dlg);
        ModalDialog(nil, item);
        good := item = 1;
        if good then begin
            display := GetNewDialog(201, nil, POINTER(-1));
            SetDItemHandle(display, 1, handle(@DrawProgress));
            GetPair(4, 2, rows, 10, 200, 50, 100);
            GetPair(6, 3, cols, 10, 200, rows, rows); { make it square if no cols sepcified }
            GetPair(8, 4, land, 15, 100, 25, 70);
            GetPair(10, 5, forest, 0, 90, 50, 90);
            GetPair(12, 6, bases, 0, 16, 8, 16);
            GetPair(14, 7, pillboxes, 0, 16, 8, 16);
            GetPair(16, 8, base_armour, 0, 90, 90, 90);
            GetPair(18, 9, base_shells, 0, 90, 90, 90);
            GetPair(20, 10, base_mines, 0, 90, 90, 90);
            DisposeDialog(dlg);
            ShowWindow(display);
        end
        else begin
            DisposeDialog(dlg);
        end;
        GetParameters := good;
    end;

    var
        a: integer;
begin
    if Get1Resource('BNDL', 128) = nil then begin
        SysBeep(1);
        halt;
    end;
    SetDAFont(geneva);
    InitUtilities;
    GetDateTime(randseed);
    mp := mapPtr(NewPtr(SizeOf(mapArray)));
    lp := landPtr(mp);
    mp2 := mapPtr(NewPtr(SizeOf(mapArray)));
    lp2 := landPtr(mp2);

    if (mp <> nil) & (mp2 <> nil) then begin
        InitCursor;
        if GetParameters then begin
            rows := rows + 2;  { leave room on the edge for the sea }
            cols := cols + 2;  { leave room on the edge for the sea }
            prog_parts := 8;
            prog_parts_done := -1;
            prog_base := rows;
            prog_base_done := 0;
            BuildMap;
            if random_location_failed then begin
                a := Alert(160, nil);
            end
            else begin
                DrawMap;
                WriteMap;
            end;
            WNE;
        end;
    end;
end.
ShowText;
DrawMap;